Cream of the Crop 25/Cream of the Crop 25.iso/program/fpk65_66.zip/SOURCE/RTL/DOS/SYSTEM.PP

Text File | 1997-02-11 | 14KB | 580 lines

{****************************************************************************

                   Copyright (c) 1993,96 by Florian Klaempfl

 ****************************************************************************}

{ Unit System für DOS-Extender von DJ Delorie }
{$define DOS}
unit system;

  interface

    { die betriebssystemunabhangigen Deklarationen einfuegen: }

    {$I SYSTEMH.INC}

    {$I HEAPH.INC}

  implementation

    { die betriebssystemunabhängigen Implementationen einfuegen: }

    {$I SYSTEM.INC}

    type
       plongint = ^longint;

    procedure halt;

      begin
         asm
            movl $0x4c00,%eax
            int $0x21
         end;
      end;

    procedure halt(errnum : byte);

      begin
         do_exit;
         asm
            movl $0x4c00,%eax
            movb 8(%ebp),%al
            int $0x21
         end;
      end;

    function paramcount : longint;

      begin
         asm
            movl _argc,%eax
            decl %eax
            leave
            ret
         end ['EAX'];
      end;

    function paramstr(l : longint) : string;

      function args : pointer;

        begin
           asm
              movl _args,%eax
              leave
              ret
           end ['EAX'];
        end;

      var
         p : ^pchar;

      begin
         if (l>=0) and (l<=paramcount) then
           begin
              p:=args;
              paramstr:=strpas(p[l]);
           end
         else paramstr:='';
      end;

    procedure randomize;

      var
         hl : longint;

      begin
         asm
            movb $0x2c,%ah
            int $0x21
            movw %cx,-4(%ebp)
            movw %dx,-2(%ebp)
         end;
         randseed:=hl;
      end;

{ use standard heap management }
{$I HEAP.INC}

{****************************************************************************
                    Unterprogramme zu Dateiverwaltung
 ****************************************************************************}

    procedure do_close(h : longint);

      begin
         asm
            movl 8(%ebp),%ebx
            movb $0x3e,%ah
            pushl %ebp
            intl $0x21
            popl %ebp
         end;
      end;

    procedure fileclosefunc(var t : textrec);

      begin
         do_close(t.handle);
      end;

    function open(f : pchar;flags : longint) : longint;

      begin
         asm
            movw $0xff02,%ax
        movl 8(%ebp),%ebx
            movl 12(%ebp),%ecx
            int $0x21
            jnc LOPEN1
            movw %ax,U_SYSTEM_INOUTRES;
            xorl %eax,%eax
         LOPEN1:
            // Returnwert ist in EAX
            leave
            ret $8
         end;
      end;

    procedure doserase(p : pchar);

      begin
         asm
            movl 8(%ebp),%edx
            movb $0x41,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            jnc LERASE1
            movw %ax,U_SYSTEM_INOUTRES;
         LERASE1:
         end;
      end;

    procedure dosrename(p1,p2 : pchar);

      begin
         asm
            movl 8(%ebp),%edx
            movl 12(%ebp),%edi
            movb $0x56,%ah
            pushl %ebp
            int $0x21
            popl %ebp
            jnc LRENAME1
            movw %ax,U_SYSTEM_INOUTRES;
         LRENAME1:
         end;
      end;

    procedure doswrite(h,addr,len : longint);

      begin
         asm
            movl 16(%ebp),%ecx
            movl 12(%ebp),%edx
            movl 8(%ebp),%ebx
            movb $0x40,%ah
            int $0x21
            jnc LDOSWRITE1
            movw %ax,U_SYSTEM_INOUTRES;
         LDOSWRITE1:
         end;
      end;

    function dosread(h,addr,len : longint) : longint;

      begin
         asm
            movl 16(%ebp),%ecx
            movl 12(%ebp),%edx
            movl 8(%ebp),%ebx
            movb $0x3f,%ah
            int $0x21
            jnc LDOSREAD1
            movw %ax,U_SYSTEM_INOUTRES;
            xorl %eax,%eax
         LDOSREAD1:
            leave
            ret $12
         end;
      end;

    function dosfilepos(handle : longint) : longint;

      begin
         asm
            movb $0x42,%ah
            movb $0x1,%al
            movl 8(%ebp),%ebx
            xorl %ecx,%ecx
            xorl %edx,%edx
            pushl %ebp
            int $0x21
            popl %ebp
            jnc LDOSFILEPOS1
            movw %ax,U_SYSTEM_INOUTRES;
            xorl %eax,%eax
            jmp LDOSFILEPOS2
         LDOSFILEPOS1:
            shll $16,%edx
            movzwl %ax,%eax
            orl %edx,%eax
         LDOSFILEPOS2:
            leave
            ret $4
         end;
      end;

    procedure dosseek(handle : longint;pos : longint);

      begin
         asm
            movb $0x42,%ah
            xorb %al,%al
            movl 8(%ebp),%ebx
            movl 12(%ebp),%edx
            // ginge auch mit SHLD
            movl %edx,%ecx
            shrl $16,%ecx
            pushl %ebp
            int $0x21
            popl %ebp
            jnc LDOSSEEK1
            movw %ax,U_SYSTEM_INOUTRES;
         LDOSSEEK1:
         end;
      end;

    function dosfilesize(handle : longint) : longint;

      function set_at_end(handle : longint) : longint;

        begin
           asm
              movb $0x42,%ah
              movb $0x2,%al
              // Vorsicht Stack: 0 %ebp; 4 retaddr;
              // 8 nextstackframe; 12 handle
              movl 12(%ebp),%ebx
              xorl %ecx,%ecx
              xorl %edx,%edx
              pushl %ebp
              int $0x21
              popl %ebp
              jnc Lset_at_end1
              movw %ax,U_SYSTEM_INOUTRES;
              xorl %eax,%eax
              jmp Lset_at_end2
           Lset_at_end1:
              shll $16,%edx
              movzwl %ax,%eax
              orl %edx,%eax
           Lset_at_end2:
              leave
              ret $8
           end;
         end;

      var
         tempfilesize : longint;
         aktfilepos : longint;

      begin
         aktfilepos:=dosfilepos(handle);
         tempfilesize:=set_at_end(handle);
         dosseek(handle,aktfilepos);
         dosfilesize:=tempfilesize;
      end;

    procedure fileopenfunc(var f : textrec);

      var
         b : array[0..255] of char;

      begin
         move(f.name[1],b,length(f.name));
         b[length(f.name)]:=#0;
         f.inoutfunc:=@fileinoutfunc;
         f.flushfunc:=@fileinoutfunc;
         f.closefunc:=@fileclosefunc;
         case f.mode of
            fminput : f.handle:=open(b,$8001);
            fmoutput : f.handle:=open(b,$8302);
            fmappend : begin
                          f.handle:=open(b,$8902);
                          f.mode:=fmoutput;
                       end;
         end;
      end;

    function eof(var t : text) : boolean;[iocheck];

      begin
         eof:=dosfilesize(textrec(t).handle)<=dosfilepos(textrec(t).handle);
         if eof then
           eof:=textrec(t).bufend<=textrec(t).bufpos;
      end;

    procedure rewrite(var f : file;l : word);[iocheck];

      var
         b : array[0..255] of char;

      begin
         filerec(f).mode:=fmoutput;
         move(filerec(f).name[1],b,length(filerec(f).name));
         b[length(filerec(f).name)]:=#0;
       filerec(f).handle:=open(b,$8302);
       filerec(f).recsize:=l;
      end;

    procedure reset(var f : file;l : word);[iocheck];

      var
         b : array[0..255] of char;

      begin
         move(filerec(f).name[1],b,length(filerec(f).name));
         b[length(filerec(f).name)]:=#0;
         {
           filerec(f).mode:=fminput;
           filerec(f).handle:=open(b,$8001);
         }
         case filemode of
            0 : begin
                   filerec(f).mode:=fminput;
                   filerec(f).handle:=open(b,$8001);
                end;
            1 : begin
                   filerec(f).mode:=fmoutput;
                   filerec(f).handle:=open(b,$8302);
                end;
            2 : begin
                   filerec(f).mode:=fminout;
                   filerec(f).handle:=open(b,$8404);
                end;
         end;
       filerec(f).recsize:=l;
      end;

    procedure rewrite(var f : file);[iocheck];

       begin
          rewrite(f,128);
       end;

    procedure reset(var f : file);[iocheck];

       begin
          reset(f,128);
       end;

    procedure blockwrite(var f : file;var buf;count : longint);[iocheck];

       var
          p : pointer;
          size : longint;

        begin
           p:=@buf;
           doswrite(filerec(f).handle,longint(p),count*filerec(f).recsize);
        end;

    procedure blockread(var f : file;var buf;count : longint;var result : longint);[iocheck];

      begin
         result:=dosread(filerec(f).handle,longint(@buf),
           count*filerec(f).recsize) div filerec(f).recsize;
      end;

    procedure blockread(var f : file;var buf;count : longint);[iocheck];

      var
         result : longint;

      begin
         blockread(f,buf,count,result);
      end;

    function filepos(var f : file) : longint;[iocheck];

      begin
         filepos:=dosfilepos(filerec(f).handle) div filerec(f).recsize;
      end;

    function filesize(var f : file) : longint;[iocheck];

      begin
         filesize:=dosfilesize(filerec(f).handle) div filerec(f).recsize;
      end;

    function eof(var f : file) : boolean;[iocheck];

      begin
         eof:=filesize(f)<=filepos(f);
      end;

    procedure seek(var f : file;pos : longint);[iocheck];

      begin
         dosseek(filerec(f).handle,pos*filerec(f).recsize);
      end;

    procedure close(var f : file);[iocheck];

      begin
         if (filerec(f).mode<>fmclosed) then
           begin
              filerec(f).mode:=fmclosed;
              do_close(filerec(f).handle);
           end;
      end;

    procedure dos_dirs(func : byte;name : pchar);

      begin
         asm
            movl 10(%ebp),%edx
            movb 8(%ebp),%ah
            int $0x21
            jnc LDOS_DIRS1
            movw %ax,U_SYSTEM_INOUTRES;
         LDOS_DIRS1:
            leave
            ret $6
         end;
      end;

    procedure _dir(func : byte;const s : string);

      var
         buffer : array[0..255] of char;

      begin
         move(s[1],buffer,length(s));
         buffer[length(s)]:=#0;
         dos_dirs(func,buffer);
      end;

    procedure mkdir(const s : string);

      begin
         _dir($39,s);
      end;

    procedure rmdir(const s : string);

      begin
         _dir($3a,s);
      end;

    procedure chdir(const s : string);

      begin
         _dir($3b,s);
      end;

    { thanks to Michael Van Canneyt <[e-mail]>, }
    { who writes this code                                               }
    procedure getdir(drivenr : byte;var dir : string);

      var
         temp : string;
         sof : pointer;
         i : byte;

      begin
         sof:=@dir[4];

         { dir[1..3] will contain '[drivenr]:\', but is not }
         { supplied by DOS, so we let dos string start at   }
         { dir[4]                                           }
         asm
            { Get dir from drivenr : 0=default, 1=A etc... }
            movb drivenr,%dl

            { put (previously saved) offset in si }
            movl sof,%esi

            { call msdos function 47H : Get dir }
            mov $0x47,%ah

            { make the call }
            int $0x21

            { Rem: if call unsuccesfull, carry is set, and AX has }
            { error code                                          }


         end;
         { Now Dir should be filled with directory in ASCIIZ, }
         { starting from dir[4]                               }
         dir[0]:=#3;
         dir[2]:=':';
         dir[3]:='\';

         i:=4;

         { conversation to Pascal string }
         while (dir[i]<>#0) do
           begin
              { convert path name to DOS }
              if dir[i]='/' then
                dir[i]:='\';
              dir[0]:=chr(i);
              inc(i);
           end;
         { upcase the string (FPKPascal function) }
         dir:=upcase(dir);
         if drivenr<>0 then   { Drive was supplied. We know it }
           dir[1]:=chr(65+drivenr-1)
         else
           begin
              { We need to get the current drive from DOS function 19H  }
              { because the drive was the default, which can be unknown }
              asm
                 movb $0x19,%ah
                 int $0x21
                 addb $65,%al
                 movb %al,i
              end;
              dir[1]:=chr(i)
           end;
      end;

  var
     i : longint;

begin
   exitproc:=nil;
   { Heapmanagement initialisieren }
   {
   for i:=1 to 32 do
     blocks[i]:=nil;
   }
   heaporg:=getheapstart;
   heapptr:=heaporg;
   _memavail:=getheapsize;
   heapend:=heaporg+_memavail;
   heaperror:=nil;
   freelist:=nil;
   { Standartinput initialisieren }
   assign(input,'');
   textrec(input).handle:=0;
   textrec(input).mode:=fminput;
   textrec(input).inoutfunc:=@fileinoutfunc;
   textrec(input).flushfunc:=@fileinoutfunc;
   { Standartoutput initialisieren }
   assign(output,'');
   textrec(output).handle:=1;
   textrec(output).mode:=fmoutput;
   textrec(output).inoutfunc:=@fileinoutfunc;
   textrec(output).flushfunc:=@fileinoutfunc;
   textrec(input).mode:=fminput;
   { kein Ein- Ausgabefehler }
   inoutres:=0;
end.